home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / UnixFile.tcl.z / UnixFile.tcl
Encoding:
Text File  |  1999-01-26  |  7.5 KB  |  408 lines

  1. # UnixFile.tcl --
  2. #
  3. #    Unix file access portibility routines.
  4. #
  5. # Copyright (c) 1996, Expert Interface Technologies
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10.  
  11. proc tixInitFileCmpt:Unix {} {
  12.  
  13. # tixFSSplit --
  14. # Splits a directory into its hierarchical components
  15. #
  16. # "hlist-type hierachical path"        <- "vpath"
  17. # "name"
  18. # "directory name"            <- "path"
  19. #
  20. proc tixFSSplit {dir} {
  21.     if [string compare [tixFSPathType $dir] "absolute"] {
  22.     error "$dir must be an absolute path"
  23.     }
  24.  
  25.     set path ""
  26.     set p ""
  27.     foreach d [tixFileSplit $dir] {
  28.     set p [tixFSJoin $p $d]
  29.     lappend path [list $p $d $p]
  30.     }
  31.     return $path
  32. }
  33.  
  34. # returns true if $dir is an valid path (always true in Unix)
  35. #
  36. proc tixFSValid {dir} {
  37.     return 1
  38. }
  39.  
  40. # Directory separator
  41. #
  42. proc tixFSSep {} {
  43.     return "/"
  44. }
  45.  
  46. # tixFSIntName
  47. #
  48. #    Returns the "virtual path" of a filename
  49. #
  50. proc tixFSIntName {dir} {
  51.     if [string compare [tixFSPathType $dir] "absolute"] {
  52.     error "$dir must be an absolute path"
  53.     }
  54.  
  55.     return $dir
  56. }
  57.  
  58. proc tixFSResolveName {p} {
  59.     return $p
  60. }
  61.  
  62.  
  63. # These subcommands of "file" only exist in Tcl 7.5+. We define the following
  64. # wrappers so that the code also works under Tcl 7.4
  65. #
  66. global tcl_version
  67. if ![string compare $tcl_version 7.4] {
  68.  
  69.     proc tixFSPathType {dir} {
  70.     if ![string compare [string index $dir 0] /] {
  71.         return "absolute"
  72.     }
  73.     if ![string compare [string index $dir 0] ~] {
  74.         return "absolute"
  75.     }
  76.     return "relative"
  77.     }
  78.  
  79.     proc tixFSJoin {dir sub} {
  80.     set joined $dir/$sub
  81.  
  82.     regsub -all {[/]+} $joined / joined
  83.     return $joined
  84.     }
  85.  
  86. } else {
  87.     proc tixFSPathType {dir} {
  88.     return [file pathtype $dir]
  89.     }
  90.  
  91.     proc tixFSJoin {dir sub} {
  92.     return [file join $dir $sub]
  93.     }
  94. }
  95.  
  96. # dir:        Make a listing of this directory
  97. # showSubDir:    Want to list the subdirectories?
  98. # showFile:    Want to list the non-directory files in this directory?
  99. # showPrevDir:    Want to list ".." as well?
  100. # showHidden:    Want to list the hidden files?
  101. #
  102. # return value:    a list of files and/or subdirectories
  103. #
  104. proc tixFSListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} {
  105.     set appPWD [pwd]
  106.  
  107.     if [catch {cd $dir} err] {
  108.     # The user has entered an invalid directory
  109.     # %% todo: prompt error, go back to last succeed directory
  110.     cd $appPWD
  111.     return ""
  112.     }
  113.  
  114.     if {$pattern == ""} {
  115.     if $showHidden {
  116.         set pattern "* .*"
  117.     } else {
  118.         set pattern *
  119.     }
  120.     } elseif {$pattern == "*"} {
  121.     if $showHidden {
  122.         set pattern "* .*"
  123.     }
  124.     }
  125.  
  126.     set list ""
  127.     foreach pat $pattern {
  128.     if [catch {set names [lsort [glob -nocomplain $pat]]} err] {
  129.         # Cannot read directory
  130.         # %% todo: show directory permission denied
  131.         continue
  132.     }
  133.  
  134.     catch {
  135.         # We are catch'ing, just in case the "file" command
  136.         # returns unexpected errors
  137.         #
  138.         foreach fname $names {
  139.         if {![string compare . $fname]} {
  140.             continue
  141.         }
  142.         if [file isdirectory $fname] {
  143.             if {![string compare ".." $fname] && !$showPrevDir} {
  144.             continue
  145.             }
  146.             if $showSubDir {
  147.             lappend list [file tail $fname]
  148.             }
  149.         } else {
  150.             if $showFile {
  151.             lappend list [file tail $fname]
  152.             }
  153.         }
  154.         }
  155.     }
  156.     }
  157.  
  158.     cd $appPWD
  159.  
  160.     if {[llength $pattern] > 1} {
  161.     # get rid of duplicated names
  162.     #
  163.     set list1 ""
  164.     set oldfile ""
  165.     foreach name [lsort $list] {
  166.         if {$name == $oldfile} {
  167.         continue
  168.         }
  169.         lappend list1 $name
  170.         set oldfile $name
  171.     }
  172.     return [_tixFSMakeList $dir $list1]
  173.     } else {
  174.     return [_tixFSMakeList $dir $list]
  175.     }
  176. }
  177.  
  178. # _tixFSMakeList -
  179. #
  180. #    Internal procedure. Used only by tixFSListDir
  181. proc _tixFSMakeList {dir list} {
  182.     set l ""
  183.     foreach file $list {
  184.     set path [tixFSJoin $dir $file]
  185.     lappend l [list $path $file $path]
  186.     }
  187.  
  188.     return $l
  189. }
  190.  
  191. # Directory separator
  192. #
  193. proc tixDirSep {} {
  194.     return "/"
  195. }
  196.  
  197.  
  198. # tixFSInfo --
  199. #
  200. #    Returns information about the file system of this OS
  201. #
  202. # hasdrives: Boolean
  203. #    Does this file system support seperate disk drives?
  204. #
  205. proc tixFSInfo {args} {
  206.     case [lindex $args 0] {
  207.     hasdrives {
  208.         return 0
  209.     }
  210.     }
  211. }
  212.  
  213. #----------------------------------------------------------------------
  214. # Obsolete
  215. #----------------------------------------------------------------------
  216.  
  217. # nativeName:    native filename used in this OS, comes from the user or
  218. #        application programmer
  219. # defParent:    if the filename is not an absolute path, treat it as a
  220. #        subfolder of $defParent
  221. proc tixFileIntName {nativeName {defParent ""}} {
  222.     if {![tixIsAbsPath $nativeName]} {
  223.     if {$defParent != ""} {
  224.         set path [tixSubFolder $defParent $nativeName]
  225.     } else {
  226.         set path $nativeName
  227.     }
  228.     } else {
  229.     set path $nativeName
  230.     }
  231.  
  232.     set intName ""
  233.     set path [tixFile trimslash [tixFile tildesubst $path]]
  234.     foreach name [tixFileSplit $path] {
  235.     set intName [tixSubFolder $intName $name]
  236.     }
  237.     return $intName
  238. }
  239.  
  240. proc tixNativeName {name {mustBeAbs ""}} {
  241.     return $name
  242. }
  243.  
  244. proc tixFileDisplayName {intName} {
  245.     if {$intName == "/"} {
  246.     return "/"
  247.     } else {
  248.     return [file tail $intName]
  249.     }
  250. }
  251.  
  252.  
  253. proc tixFileSplit {intName} {
  254.  
  255.     set l ""
  256.     foreach n [split $intName /] {
  257.     if {$n == ""} {
  258.         continue
  259.     }
  260.     if {$n == "."} {
  261.         continue
  262.     }
  263.  
  264.     lappend l $n
  265.     }
  266.     
  267.  
  268.     while 1 {
  269.     set idx [lsearch $l ".."]
  270.     if {$idx == -1} {
  271.         break;
  272.     }
  273.     set l [lreplace $l [expr $idx -1] $idx]
  274.     }
  275.  
  276.  
  277.     if {[string index $intName 0] == "/"} {
  278.     return [concat "/" $l]
  279.     } else {
  280.     return $l
  281.     }
  282. }
  283.  
  284. proc tixSubFolder {parent sub} {
  285.     if {$parent == ""} {
  286.     return $sub
  287.     }
  288.     if {$parent == "/"} {
  289.     return /$sub
  290.     } else {
  291.     return $parent/$sub
  292.     }
  293. }
  294.  
  295. # dir:        Make a listing of this directory
  296. # showSubDir:    Want to list the subdirectories?
  297. # showFile:    Want to list the non-directory files in this directory?
  298. # showPrevDir:    Want to list ".." as well?
  299. # showHidden:    Want to list the hidden files?
  300. #
  301. # return value:    a list of files and/or subdirectories
  302. #
  303. proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} { 
  304.  
  305.     set appPWD [pwd]
  306.  
  307.     if [catch {cd $dir} err] {
  308.     # The user has entered an invalid directory
  309.     # %% todo: prompt error, go back to last succeed directory
  310.     cd $appPWD
  311.     return ""
  312.     }
  313.  
  314.     if {$pattern == ""} {
  315.     if $showHidden {
  316.         set pattern "* .*"
  317.     } else {
  318.         set pattern *
  319.     }
  320.     } elseif {$pattern == "*"} {
  321.     if $showHidden {
  322.         set pattern "* .*"
  323.     }
  324.     }
  325.  
  326.     set list ""
  327.     foreach pat $pattern {
  328.     if [catch {set names [lsort [glob -nocomplain $pat]]} err] {
  329.         # Cannot read directory
  330.         # %% todo: show directory permission denied
  331.         continue
  332.     }
  333.  
  334.     catch {
  335.         # We are catch'ing, just in case the "file" command
  336.         # returns unexpected errors
  337.         #
  338.         foreach fname $names {
  339.         if {![string compare . $fname]} {
  340.             continue
  341.         }
  342.         if [file isdirectory $fname] {
  343.             if {![string compare ".." $fname] && !$showPrevDir} {
  344.             continue
  345.             }
  346.             if $showSubDir {
  347.             lappend list [file tail $fname]
  348.             }
  349.         } else {
  350.             if $showFile {
  351.             lappend list [file tail $fname]
  352.             }
  353.         }
  354.         }
  355.     }
  356.     }
  357.  
  358.     cd $appPWD
  359.  
  360.     if {[llength $pattern] > 1} {
  361.     set list1 ""
  362.     set oldfile ""
  363.     foreach name [lsort $list] {
  364.         if {$name == $oldfile} {
  365.         continue
  366.         }
  367.         lappend list1 $name
  368.         set oldfile $name
  369.     }
  370.     return $list1
  371.     } else {
  372.     return $list
  373.     }
  374. }
  375.  
  376. # returns the "root directory" of this operating system
  377. #
  378. proc tixRootDir {} {
  379.     return "/"
  380. }
  381.  
  382. proc tixIsAbsPath {nativeName} {
  383.     set c [string index $nativeName 0]
  384.     if {$c == "~" || $c == "/"} {
  385.     return 1
  386.     } else {
  387.     return 0
  388.     }
  389. }
  390.  
  391. proc tixVerifyFile {file} {
  392.     return [tixFileIntName $file]
  393. }
  394.  
  395. proc tixFilePattern {args} {
  396.     if {[lsearch $args allFiles] != -1} {
  397.     return *
  398.     }
  399.     return *
  400. }
  401. }
  402.  
  403.  
  404.  
  405.  
  406.  
  407.